Celestin Apprentice 5/Apprentice-Release5.iso/Source Code/Pascal/Applications/P4⁄Mac 1.0/Mac source/pint⁄m.p

Text File | 1994-07-29 | 34.0 KB | 1,738 lines | [TEXT/PJMM]

(*Assembler and interpreter of Pascal code*)
(*K. Jensen, N. Wirth, Ch. Jacobi, ETH May 76*)

{Mac port by Ingemar Ragnemalm 1994. Look for "{” comments to find my changes.}

program pcode (input, output, prd, prr);

(* Note for the implementation.}
{   ===========================}
{This interpreter is written for the case where all the fundamental types}
{take one storage unit.}
{In an actual implementation, the handling of the sp pointer has to take}
{into account the fact that the types may have lengths different from one:}
{in push and pop operations the sp has to be increased and decreased not}
{by 1, but by a number depending on the type concerned.}
{However, where the number of units of storage has been computed by the}
{compiler, the value must not be corrected, since the lengths of the types}
{involved have already been taken into account.}
{                                 *)


    label
        1;
    const
        codemax = 8650;
        pcmax = 17500;
        maxstk = 13650; (* size of variable store *)
        overi = 13655; (* size of integer constant table = 5 *)
        overr = 13660; (* size of real constant table = 5 *)
        overs = 13730; (* size of set constant table = 70 *)
        overb = 13820;
        overm = 18000;
        maxstr = 18001;
        largeint = 26144;
        begincode = 3;
        inputadr = 5;
        outputadr = 6;
        prdadr = 7;
        prradr = 8;
        duminst = 62;

    type
        bit4 = 0..15;
        bit6 = 0..127;
        bit20 = -26143..26143;
        datatype = (undef, int, reel, bool, sett, adr, mark, car);
        address = -1..maxstr;
        beta = string[25]; {IR: Was: packed array[1..25] of char; (*error message*)
        settype = set of 0..58;
        alfa = packed array[1..10] of char;

        codeType = array[0..codemax] of packed record   (* the program *)
                op1: bit6;
                p1: bit4;
                q1: bit20;
                op2: bit6;
                p2: bit4;
                q2: bit20
            end;
        codePtr = ^codeType;

        storeType = array[0..overm] of record
                case datatype of
                    int: (
                            vi: integer
                    );
                    reel: (
                            vr: real
                    );
                    bool: (
                            vb: boolean
                    );
                    sett: (
                            vs: settype
                    );
                    car: (
                            vc: char
                    );
                    adr: (
                            va: address
                    );
                         (*address in store*)
                    mark: (
                            vm: integer
                    )
            end;
        storePtr = ^storeType;

    var
        code: codePtr;

        pc: 0..pcmax;     (*program address register*)
        op: bit6;
        p: bit4;
        q: bit20;  (*instruction register*)

        store: storePtr;

        mp, sp, np, ep: address;  (* address registers *)
       (*mp  points to beginning of a data segment}
{     sp  points to top of the stack}
{     ep  points to the maximum extent of the stack}
{     np  points to top of the dynamically allocated area*)

        interpreting: boolean;
        prd, prr: text;(*prd for read only, prr for write only *)

        instr: array[bit6] of alfa; (* mnemonic instruction codes *)
        cop: array[bit6] of integer;
        sptable: array[0..20] of alfa; (*standard functions and procedures*)

      (*locally used for interpreting one instruction*)
        ad, ad1: address;
        b: boolean;
        i, j, i1, i2: integer;
        c: char;

(*--------------------------------------------------------------------*)

    procedure load;
        const
            maxlabel = 1850;
        type
            labelst = (entered, defined); (*label situation*)
            labelrg = 0..maxlabel;       (*label range*)
            labelrec = record
                    val: address;
                    st: labelst
                end;
        var
            icp, rcp, scp, bcp, mcp: address;  (*pointers to next free position*)
            word: array[1..10] of char;
            i: integer;
            ch: char;
            labeltab: array[labelrg] of labelrec;
            labelvalue: address;

        procedure init;
            var
                i: integer;
        begin
            instr[0] := 'lod       ';
            instr[1] := 'ldo       ';
            instr[2] := 'str       ';
            instr[3] := 'sro       ';
            instr[4] := 'lda       ';
            instr[5] := 'lao       ';
            instr[6] := 'sto       ';
            instr[7] := 'ldc       ';
            instr[8] := '...       ';
            instr[9] := 'ind       ';
            instr[10] := 'inc       ';
            instr[11] := 'mst       ';
            instr[12] := 'cup       ';
            instr[13] := 'ent       ';
            instr[14] := 'ret       ';
            instr[15] := 'csp       ';
            instr[16] := 'ixa       ';
            instr[17] := 'equ       ';
            instr[18] := 'neq       ';
            instr[19] := 'geq       ';
            instr[20] := 'grt       ';
            instr[21] := 'leq       ';
            instr[22] := 'les       ';
            instr[23] := 'ujp       ';
            instr[24] := 'fjp       ';
            instr[25] := 'xjp       ';
            instr[26] := 'chk       ';
            instr[27] := 'eof       ';
            instr[28] := 'adi       ';
            instr[29] := 'adr       ';
            instr[30] := 'sbi       ';
            instr[31] := 'sbr       ';
            instr[32] := 'sgs       ';
            instr[33] := 'flt       ';
            instr[34] := 'flo       ';
            instr[35] := 'trc       ';
            instr[36] := 'ngi       ';
            instr[37] := 'ngr       ';
            instr[38] := 'sqi       ';
            instr[39] := 'sqr       ';
            instr[40] := 'abi       ';
            instr[41] := 'abr       ';
            instr[42] := 'not       ';
            instr[43] := 'and       ';
            instr[44] := 'ior       ';
            instr[45] := 'dif       ';
            instr[46] := 'int       ';
            instr[47] := 'uni       ';
            instr[48] := 'inn       ';
            instr[49] := 'mod       ';
            instr[50] := 'odd       ';
            instr[51] := 'mpi       ';
            instr[52] := 'mpr       ';
            instr[53] := 'dvi       ';
            instr[54] := 'dvr       ';
            instr[55] := 'mov       ';
            instr[56] := 'lca       ';
            instr[57] := 'dec       ';
            instr[58] := 'stp       ';
            instr[59] := 'ord       ';
            instr[60] := 'chr       ';
            instr[61] := 'ujc       ';

            sptable[0] := 'get       ';
            sptable[1] := 'put       ';
            sptable[2] := 'rst       ';
            sptable[3] := 'rln       ';
            sptable[4] := 'new       ';
            sptable[5] := 'wln       ';
            sptable[6] := 'wrs       ';
            sptable[7] := 'eln       ';
            sptable[8] := 'wri       ';
            sptable[9] := 'wrr       ';
            sptable[10] := 'wrc       ';
            sptable[11] := 'rdi       ';
            sptable[12] := 'rdr       ';
            sptable[13] := 'rdc       ';
            sptable[14] := 'sin       ';
            sptable[15] := 'cos       ';
            sptable[16] := 'exp       ';
            sptable[17] := 'log       ';
            sptable[18] := 'sqt       ';
            sptable[19] := 'atn       ';
            sptable[20] := 'sav       ';

            cop[0] := 105;
            cop[1] := 65;
            cop[2] := 70;
            cop[3] := 75;
            cop[6] := 80;
            cop[9] := 85;
            cop[10] := 90;
            cop[26] := 95;
            cop[57] := 100;

            pc := begincode;
            icp := maxstk + 1;
            rcp := overi + 1;
            scp := overr + 1;
            bcp := overs + 2;
            mcp := overb + 1;
            for i := 1 to 10 do
                word[i] := ' ';
            for i := 0 to maxlabel do
                with labeltab[i] do
                    begin
                        val := -1;
                        st := entered
                    end;
            reset(prd);
        end;(*init*)

        procedure errorl (theString: beta); (*error in loading*)
        begin
            writeln;
            write(theString);
            halt
        end; (*errorl*)

        procedure update (x: labelrg); (*when a label definition lx is found*)
            var
                curr, succ: -1..pcmax;  (*resp. current element and successor element}
{                   of a list of future references*)
                endlist: boolean;
        begin
            if labeltab[x].st = defined then
                errorl(' duplicated label           ')
            else
                begin
                    if labeltab[x].val <> -1 then (*forward reference(s)*)
                        begin
                            curr := labeltab[x].val;
                            endlist := false;
                            while not endlist do
                                with code^[curr div 2] do
                                    begin
                                        if odd(curr) then
                                            begin
                                                succ := q2;
                                                q2 := labelvalue
                                            end
                                        else
                                            begin
                                                succ := q1;
                                                q1 := labelvalue
                                            end;
                                        if succ = -1 then
                                            endlist := true
                                        else
                                            curr := succ
                                    end;
                        end;
                    labeltab[x].st := defined;
                    labeltab[x].val := labelvalue;
                end
        end;(*update*)

        procedure assemble;
        forward;

        procedure generate;(*generate segment of code*)
            var
                x: integer; (* label number *)
                again: boolean;
        begin
            again := true;
            while again do
                begin
                    read(prd, ch);(* first character of line*)
                    case ch of
                        'i':
                            readln(prd);
                        'l':
                            begin
                                read(prd, x);
                                if not eoln(prd) then
                                    read(prd, ch);
                                if ch = '=' then
                                    read(prd, labelvalue)
                                else
                                    labelvalue := pc;
                                update(x);
                                readln(prd);
                            end;
                        'q':
                            begin
                                again := false;
                                readln(prd)
                            end;
                        ' ':
                            begin
                                read(prd, ch);
                                assemble
                            end
                    end;
                end
        end; (*generate*)

        procedure assemble; (*translate symbolic code into machine code and store*)
            label
                1;     (*goto 1 for instructions without code generation*)
            var
                name: alfa;
                b: boolean;
                r: real;
                s: settype;
                c1: char;
                i, s1, lb, ub: integer;

            procedure lookup (x: labelrg); (* search in label table*)
            begin
                case labeltab[x].st of
                    entered:
                        begin
                            q := labeltab[x].val;
                            labeltab[x].val := pc
                        end;
                    defined:
                        q := labeltab[x].val
                end(*case label..*)
            end;(*lookup*)

            procedure labelsearch;
                var
                    x: labelrg;
            begin
                while (ch <> 'l') and not eoln(prd) do
                    read(prd, ch);
                read(prd, x);
                lookup(x)
            end;(*labelsearch*)

            procedure getname;
                var
                    i: integer; {fix for pack}
            begin
                word[1] := ch;
                read(prd, word[2], word[3]);
                if not eoln(prd) then
                    read(prd, ch); (*next character*)
{pack(word, 1, name) doesn't exist, replace by:}
                for i := 1 to 10 do {pack}
                    name[i] := word[i]; {pack}
            end; (*getname*)

            procedure typesymbol;
                var
                    i: integer;
            begin
                if ch <> 'i' then
                    begin
                        case ch of
                            'a':
                                i := 0;
                            'r':
                                i := 1;
                            's':
                                i := 2;
                            'b':
                                i := 3;
                            'c':
                                i := 4;
                        end;
                        op := cop[op] + i;
                    end;
            end; (*typesymbol*)

        begin
            p := 0;
            q := 0;
            op := 0;
            getname;
            instr[duminst] := name;
            while instr[op] <> name do
                op := op + 1;
            if op = duminst then
                errorl(' illegal instruction     ');

            case op of  (* get parameters p,q *)

      (*equ,neq,geq,grt,leq,les*)
                17, 18, 19, 20, 21, 22:
                    begin
                        case ch of
                            'a':
                                ; (*p = 0*)
                            'i':
                                p := 1;
                            'r':
                                p := 2;
                            'b':
                                p := 3;
                            's':
                                p := 4;
                            'c':
                                p := 6;
                            'm':
                                begin
                                    p := 5;
                                    read(prd, q)
                                end
                        end
                    end;

      (*lod,str*)
                0, 2:
                    begin
                        typesymbol;
                        read(prd, p, q)
                    end;

4  (*lda*)
                :
                    read(prd, p, q);

12 (*cup*)
                :
                    begin
                        read(prd, p);
                        labelsearch
                    end;

11 (*mst*)
                :
                    read(prd, p);

14 (*ret*)
                :
                    case ch of
                        'p':
                            p := 0;
                        'i':
                            p := 1;
                        'r':
                            p := 2;
                        'c':
                            p := 3;
                        'b':
                            p := 4;
                        'a':
                            p := 5
                    end;

      (*lao,ixa,mov*)
                5, 16, 55:
                    read(prd, q);

      (*ldo,sro,ind,inc,dec*)
                1, 3, 9, 10, 57:
                    begin
                        typesymbol;
                        read(prd, q)
                    end;

      (*ujp,fjp,xjp*)
                23, 24, 25:
                    labelsearch;

13 (*ent*)
                :
                    begin
                        read(prd, p);
                        labelsearch
                    end;

15 (*csp*)
                :
                    begin
                        for i := 1 to 9 do
                            read(prd, ch);
                        getname;
                        while name <> sptable[q] do
                            q := q + 1
                    end;

7 (*ldc*)
                :
                    begin
                        case ch of  (*get q*)
                            'i':
                                begin
                                    p := 1;
                                    read(prd, i);
                                    if abs(i) >= largeint then
                                        begin
                                            op := 8;
                                            store^[icp].vi := i;
                                            q := maxstk;
                                            repeat
                                                q := q + 1
                                            until store^[q].vi = i;
                                            if q = icp then
                                                begin
                                                    icp := icp + 1;
                                                    if icp = overi then
                                                        errorl(' integer table overflow  ');
                                                end
                                        end
                                    else
                                        q := i
                                end;

                            'r':
                                begin
                                    op := 8;
                                    p := 2;
                                    read(prd, r);
                                    store^[rcp].vr := r;
                                    q := overi;
                                    repeat
                                        q := q + 1
                                    until store^[q].vr = r;
                                    if q = rcp then
                                        begin
                                            rcp := rcp + 1;
                                            if rcp = overr then
                                                errorl(' real table overflow     ');
                                        end
                                end;

                            'n':
                                ; (*p,q = 0*)

                            'b':
                                begin
                                    p := 3;
                                    read(prd, q)
                                end;

                            'c':
                                begin
                                    p := 6;
                                    repeat
                                        read(prd, ch);
                                    until ch <> ' ';
                                    if ch <> '''' then
                                        errorl(' illegal character       ');
                                    read(prd, ch);
                                    q := ord(ch);
                                    read(prd, ch);
                                    if ch <> '''' then
                                        errorl(' illegal character       ');
                                end;
                            '(':
                                begin
                                    op := 8;
                                    p := 4;
                                    s := [];
                                    read(prd, ch);
                                    while ch <> ')' do
                                        begin
                                            read(prd, s1, ch);
                                            s := s + [s1]
                                        end;
                                    store^[scp].vs := s;
                                    q := overr;
                                    repeat
                                        q := q + 1
                                    until store^[q].vs = s;
                                    if q = scp then
                                        begin
                                            scp := scp + 1;
                                            if scp = overs then
                                                errorl(' set table overflow      ');
                                        end
                                end
                        end (*case*)
                    end;

26 (*chk*)
                :
                    begin
                        typesymbol;
                        read(prd, lb, ub);
                        if op = 95 then
                            q := lb
                        else
                            begin
                                store^[bcp - 1].vi := lb;
                                store^[bcp].vi := ub;
                                q := overs;
                                repeat
                                    q := q + 2
                                until (store^[q - 1].vi = lb) and (store^[q].vi = ub);
                                if q = bcp then
                                    begin
                                        bcp := bcp + 2;
                                        if bcp = overb then
                                            errorl(' boundary table overflow ');
                                    end
                            end
                    end;

56 (*lca*)
                :
                    begin
                        if mcp + 16 >= overm then
                            errorl(' multiple table overflow ');
                        mcp := mcp + 16;
                        q := mcp;
                        for i := 0 to 15 do (*stringlgth*)
                            begin
                                read(prd, ch);
                                store^[q + i].vc := ch
                            end;
                    end;

6 (*sto*)
                :
                    typesymbol;

                27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 58:
                    ;

      (*ord,chr*)
                59, 60:
                    goto 1;

61 (*ujc*)
                :
                    ; (*must have same length as ujp*)

            end; (*case*)

      (* store instruction *)
            with code^[pc div 2] do
                if odd(pc) then
                    begin
                        op2 := op;
                        p2 := p;
                        q2 := q
                    end
                else
                    begin
                        op1 := op;
                        p1 := p;
                        q1 := q
                    end;
            pc := pc + 1;
1:
            readln(prd);
        end; (*assemble*)

    begin (*load*)
        init;
        generate;
        pc := 0;
        generate;
    end; (*load*)

(*------------------------------------------------------------------------*)

    procedure pmd;
        var
            s: integer;
            i: integer;

        procedure pt;
        begin
            write(s : 6);
            if abs(store^[s].vi) < maxint then
                write(store^[s].vi)
            else
                write('too big ');
            s := s - 1;
            i := i + 1;
            if i = 4 then
                begin
                    writeln(output);
                    i := 0
                end;
        end; (*pt*)

    begin
        write(' pc =', pc - 1 : 5, ' op =', op : 3, '  sp =', sp : 5, '  mp =', mp : 5, '  np =', np : 5);
        writeln;
        writeln('--------------------------------------');

        s := sp;
        i := 0;
        while s >= 0 do
            pt;
        s := maxstk;
        while s >= np do
            pt;
    end; (*pmd*)

    procedure errori (theString: beta);
    begin
        writeln;
        writeln(theString);
        pmd;
        goto 1
    end;(*errori*)

    function base (ld: integer): address;
        var
            ad: address;
    begin
        ad := mp;
        while ld > 0 do
            begin
                ad := store^[ad + 1].vm;
                ld := ld - 1
            end;
        base := ad
    end; (*base*)

    procedure compare;
(*comparing is only correct if result by comparing integers will be*)
    begin
        i1 := store^[sp].va;
        i2 := store^[sp + 1].va;
        i := 0;
        b := true;
        while b and (i <> q) do
            if store^[i1 + i].vi = store^[i2 + i].vi then
                i := i + 1
            else
                b := false
    end; (*compare*)


    var
        prrOpen: Boolean;

    procedure CheckPrr; {Fix to avoid a prr file if we don't need it!}
        var
            newFile: Str255;
    begin
        if prrOpen then
            exit(CheckPrr);
        newFile := 'p4.err';
        newFile := NewFileName('Output file?');
        rewrite(prr, newFile);
    end;


    procedure callsp;
        var
            line: boolean;
            adptr, adelnt: address;
            i: integer;

        procedure readi (var f: text);
            var
                ad: address;
        begin
            ad := store^[sp - 1].va;
            read(f, store^[ad].vi);
            store^[store^[sp].va].vc := f^;
            sp := sp - 2
        end;(*readi*)

        procedure readr (var f: text);
            var
                ad: address;
        begin
            ad := store^[sp - 1].va;
            read(f, store^[ad].vr);
            store^[store^[sp].va].vc := f^;
            sp := sp - 2
        end;(*readr*)

        procedure readc (var f: text);
            var
                c: char;
                ad: address;
        begin
            read(f, c);
            ad := store^[sp - 1].va;
            store^[ad].vc := c;
            store^[store^[sp].va].vc := f^;
            store^[store^[sp].va].vi := ord(f^);
            sp := sp - 2
        end;(*readc*)

        procedure writestr (var f: text);
            var
                i, j, k: integer;
                ad: address;
        begin
            ad := store^[sp - 3].va;
            k := store^[sp - 2].vi;
            j := store^[sp - 1].vi;
     (* j and k are numbers of characters *)
            if k > j then
                for i := 1 to k - j do
                    write(f, ' ')
            else
                j := k;
            for i := 0 to j - 1 do
                write(f, store^[ad + i].vc);
            sp := sp - 4
        end;(*writestr*)

        procedure getfile (var f: text);
            var
                ad: address;
        begin
            ad := store^[sp].va;
            get(f);
            store^[ad].vc := f^;
            sp := sp - 1
        end;(*getfile*)

        procedure putfile (var f: text);
            var
                ad: address;
        begin
            ad := store^[sp].va;
            f^ := store^[ad].vc;
            put(f);
            sp := sp - 1;
        end;(*putfile*)

    begin (*callsp*)
        case q of
0 (*get*)
            :
                case store^[sp].va of
                    5:
                        getfile(input);
                    6:
                        errori(' get on output file      ');
                    7:
                        getfile(prd);
                    8:
                        errori(' get on prr file     ')
                end;
1 (*put*)
            :
                case store^[sp].va of
                    5:
                        errori(' put on read file    ');
                    6:
                        putfile(output);
                    7:
                        errori(' put on prd file     ');
                    8:
                        begin
                            CheckPrr; {Fix to avoid a prr file if we don't need it!}
                            putfile(prr)
                        end;
                end;
2 (*rst*)
            :
                begin
            (*for testphase*)
                    np := store^[sp].va;
                    sp := sp - 1
                end;
3 (*rln*)
            :
                begin
                    case store^[sp].va of
                        5:
                            begin
                                readln(input);
                                store^[inputadr].vc := input^
                            end;
                        6:
                            errori(' readln on output file   ');
                        7:
                            begin
                                readln(input);
                                store^[inputadr].vc := input^
                            end;
                        8:
                            errori(' readln on prr file      ')
                    end;
                    sp := sp - 1
                end;
4 (*new*)
            :
                begin
                    ad := np - store^[sp].va;
              (*top of stack gives the length in units of storage *)
                    if ad <= ep then
                        errori(' store overflow      ');
                    np := ad;
                    ad := store^[sp - 1].va;
                    store^[ad].va := np;
                    sp := sp - 2
                end;
5 (*wln*)
            :
                begin
                    case store^[sp].va of
                        5:
                            errori(' writeln on input file   ');
                        6:
                            writeln(output);
                        7:
                            errori(' writeln on prd file     ');
                        8:
                            begin
                                CheckPrr; {Fix to avoid a prr file if we don't need it!}
                                writeln(prr)
                            end;
                    end;
                    sp := sp - 1
                end;
6 (*wrs*)
            :
                case store^[sp].va of
                    5:
                        errori(' write on input file     ');
                    6:
                        writestr(output);
                    7:
                        errori(' write on prd file       ');
                    8:
                        begin
                            CheckPrr; {Fix to avoid a prr file if we don't need it!}
                            writestr(prr)
                        end;
                end;
7 (*eln*)
            :
                begin
                    case store^[sp].va of
                        5:
                            line := eoln(input);
                        6:
                            errori(' eoln output file    ');
                        7:
                            line := eoln(prd);
                        8:
                            errori(' eoln on prr file    ')
                    end;
                    store^[sp].vb := line
                end;
8 (*wri*)
            :
                begin
                    case store^[sp].va of
                        5:
                            errori(' write on input file     ');
                        6:
                            write(output, store^[sp - 2].vi : store^[sp - 1].vi);
                        7:
                            errori(' write on prd file       ');
                        8:
                            begin
                                CheckPrr; {Fix to avoid a prr file if we don't need it!}
                                write(prr, store^[sp - 2].vi : store^[sp - 1].vi)
                            end;
                    end;
                    sp := sp - 3
                end;
9 (*wrr*)
            :
                begin
                    case store^[sp].va of
                        5:
                            errori(' write on input file     ');
                        6:
                            write(output, store^[sp - 2].vr : store^[sp - 1].vi);
                        7:
                            errori(' write on prd file       ');
                        8:
                            begin
                                CheckPrr; {Fix to avoid a prr file if we don't need it!}
                                write(prr, store^[sp - 2].vr : store^[sp - 1].vi)
                            end;
                    end;
                    sp := sp - 3
                end;
10(*wrc*)
            :
                begin
                    case store^[sp].va of
                        5:
                            errori(' write on input file     ');
                        6:
                            write(output, store^[sp - 2].vc : store^[sp - 1].vi);
                        7:
                            errori(' write on prd file       ');
                        8:
                            begin
                                CheckPrr; {Fix to avoid a prr file if we don't need it!}
                                write(prr, chr(store^[sp - 2].vi) : store^[sp - 1].vi);
                            end;
                    end;
                    sp := sp - 3
                end;
11(*rdi*)
            :
                case store^[sp].va of
                    5:
                        readi(input);
                    6:
                        errori(' read on output file     ');
                    7:
                        readi(prd);
                    8:
                        errori(' read on prr file    ')
                end;
12(*rdr*)
            :
                case store^[sp].va of
                    5:
                        readr(input);
                    6:
                        errori(' read on output file     ');
                    7:
                        readr(prd);
                    8:
                        errori(' read on prr file    ')
                end;
13(*rdc*)
            :
                case store^[sp].va of
                    5:
                        readc(input);
                    6:
                        errori(' read on output file     ');
                    7:
                        readc(prd);
                    8:
                        errori(' read on prr file    ')
                end;
14(*sin*)
            :
                store^[sp].vr := sin(store^[sp].vr);
15(*cos*)
            :
                store^[sp].vr := cos(store^[sp].vr);
16(*exp*)
            :
                store^[sp].vr := exp(store^[sp].vr);
17(*log*)
            :
                store^[sp].vr := ln(store^[sp].vr);
18(*sqt*)
            :
                store^[sp].vr := sqrt(store^[sp].vr);
19(*atn*)
            :
                store^[sp].vr := arctan(store^[sp].vr);
20(*sav*)
            :
                begin
                    ad := store^[sp].va;
                    store^[ad].va := np;
                    sp := sp - 1
                end;
        end;(*case q*)
    end;(*callsp*)

    function GetInFile: Str255;
        var
            message, count: Integer;
            theAppFile: AppFile;
    begin
        CountAppFiles(message, count);
        if count > 0 then
            begin
                GetAppFiles(1, theAppFile);
                if SetVol(nil, theAppFile.vRefNum) <> noErr then
                    ; {We ignore errors for now}
                GetInFile := theAppFile.fname;
            end
        else
            begin
                GetInFile := OldFileName('');
            end;
    end;

{For Stdfile-dialogs:}
    var
        oldFile: Str255;
        theTextRect: Rect;
begin (* main *)
    theTextRect := screenBits.bounds;
    theTextRect.top := theTextRect.top + 40; {For menu bar and window top}
    InsetRect(theTextRect, 10, 10);
    SetTextRect(theTextRect);
    ShowText;
    Writeln('Welcome to the P4Mac p-code interpreter!');
    Writeln('This program is based on the Public Domain compiler P4.');
    Writeln('Quick port for the Mac by Ingemar Ragnemalm - and don''t ask me why.');
    Writeln('•••');

{Fix for Think Pascal's stupid 32k limit:}
    code := codePtr(NewPtr(sizeof(codeType)));
    if code = nil then
        begin
            SysBeep(1);
            Writeln('Out of memory trying to allocate ', sizeof(codeType) : 1, ' bytes for "code".');
            Writeln('Click mouse to exit.');
            while not Button do
                ;
            halt;
        end;
    store := storePtr(NewPtr(sizeof(storeType)));
    if store = nil then
        begin
            SysBeep(1);
            Writeln('Out of memory trying to allocate ', sizeof(storeType) : 1, ' bytes for "store".');
            Writeln('Click mouse to exit.');
            while not Button do
                ;
            halt;
        end;

{close(prd); {Behövs det?}

    oldFile := GetInFile;
    reset(prd, oldFile);

{newFile := NewFileName('Output file?');}

{Borde inte rewrite'a prr förrän vi ser att det krävs nåt ut, väl?}
{rewrite(prr, newFile); {Var förr rewrite(prr)!!!}
    prrOpen := false; {Not open yet!}

    load; (* assembles and stores code *)
  (* writeln(output); for testing *)
    pc := 0;
    sp := -1;
    mp := 0;
    np := maxstk + 1;
    ep := 5;
{store^[inputadr].vc := input^;}
{store^[prdadr].vc := prd^; {???}
    interpreting := true;

    while interpreting do
        begin
    (*fetch*)
            with code^[pc div 2] do
                if odd(pc) then
                    begin
                        op := op2;
                        p := p2;
                        q := q2
                    end
                else
                    begin
                        op := op1;
                        p := p1;
                        q := q1
                    end;
            pc := pc + 1;

    (*execute*)
            case op of

                105, 106, 107, 108, 109, 0 (*lod*)
                :
                    begin
                        ad := base(p) + q;
                        sp := sp + 1;
                        store^[sp] := store^[ad]
                    end;

                65, 66, 67, 68, 69, 1 (*ldo*)
                :
                    begin
                        sp := sp + 1;
                        store^[sp] := store^[q]
                    end;

                70, 71, 72, 73, 74, 2 (*str*)
                :
                    begin
                        store^[base(p) + q] := store^[sp];
                        sp := sp - 1
                    end;

                75, 76, 77, 78, 79, 3 (*sro*)
                :
                    begin
                        store^[q] := store^[sp];
                        sp := sp - 1
                    end;

4 (*lda*)
                :
                    begin
                        sp := sp + 1;
                        store^[sp].va := base(p) + q
                    end;

5 (*lao*)
                :
                    begin
                        sp := sp + 1;
                        store^[sp].va := q
                    end;

                80, 81, 82, 83, 84, 6 (*sto*)
                :
                    begin
                        store^[store^[sp - 1].va] := store^[sp];
                        sp := sp - 2;
                    end;

7 (*ldc*)
                :
                    begin
                        sp := sp + 1;
                        if p = 1 then
                            begin
                                store^[sp].vi := q;
                            end
                        else if p = 6 then
                            store^[sp].vc := chr(q)
                        else if p = 3 then
                            store^[sp].vb := q = 1
                        else (* load nil *)
                            store^[sp].va := maxstr
                    end;

8 (*lci*)
                :
                    begin
                        sp := sp + 1;
                        store^[sp] := store^[q]
                    end;

                85, 86, 87, 88, 89, 9 (*ind*)
                :
                    begin
                        ad := store^[sp].va + q;
              (* q is a number of storage units *)
                        store^[sp] := store^[ad]
                    end;

                90, 91, 92, 93, 94, 10 (*inc*)
                :
                    store^[sp].vi := store^[sp].vi + q;

11 (*mst*)
                :
                    begin (*p=level of calling procedure minus level of called}
{                  procedure + 1;  set dl and sl, increment sp*)
               (* then length of this element is}
{              max(intsize,realsize,boolsize,charsize,ptrsize *)
                        store^[sp + 2].vm := base(p);
               (* the length of this element is ptrsize *)
                        store^[sp + 3].vm := mp;
               (* idem *)
                        store^[sp + 4].vm := ep;
               (* idem *)
                        sp := sp + 5
                    end;

12 (*cup*)
                :
                    begin (*p=no of locations for parameters, q=entry point*)
                        mp := sp - (p + 4);
                        store^[mp + 4].vm := pc;
                        pc := q
                    end;

13 (*ent*)
                :
                    if p = 1 then
                        begin
                            sp := mp + q; (*q = length of dataseg*)
                            if sp > np then
                                errori(' store overflow      ');
                        end
                    else
                        begin
                            ep := sp + q;
                            if ep > np then
                                errori(' store overflow      ');
                        end;
            (*q = max space required on stack*)

14 (*ret*)
                :
                    begin
                        case p of
                            0:
                                sp := mp - 1;
                            1, 2, 3, 4, 5:
                                sp := mp
                        end;
                        pc := store^[mp + 4].vm;
                        ep := store^[mp + 3].vm;
                        mp := store^[mp + 2].vm;
                    end;

15 (*csp*)
                :
                    callsp;

16 (*ixa*)
                :
                    begin
                        i := store^[sp].vi;
                        sp := sp - 1;
                        store^[sp].va := q * i + store^[sp].va;
                    end;

17 (*equ*)
                :
                    begin
                        sp := sp - 1;
                        case p of
                            1:
                                store^[sp].vb := store^[sp].vi = store^[sp + 1].vi;
                            0:
                                store^[sp].vb := store^[sp].va = store^[sp + 1].va;
                            6:
                                store^[sp].vb := store^[sp].vc = store^[sp + 1].vc;
                            2:
                                store^[sp].vb := store^[sp].vr = store^[sp + 1].vr;
                            3:
                                store^[sp].vb := store^[sp].vb = store^[sp + 1].vb;
                            4:
                                store^[sp].vb := store^[sp].vs = store^[sp + 1].vs;
                            5:
                                begin
                                    compare;
                                    store^[sp].vb := b;
                                end;
                        end; (*case p*)
                    end;

18 (*neq*)
                :
                    begin
                        sp := sp - 1;
                        case p of
                            0:
                                store^[sp].vb := store^[sp].va <> store^[sp + 1].va;
                            1:
                                store^[sp].vb := store^[sp].vi <> store^[sp + 1].vi;
                            6:
                                store^[sp].vb := store^[sp].vc <> store^[sp + 1].vc;
                            2:
                                store^[sp].vb := store^[sp].vr <> store^[sp + 1].vr;
                            3:
                                store^[sp].vb := store^[sp].vb <> store^[sp + 1].vb;
                            4:
                                store^[sp].vb := store^[sp].vs <> store^[sp + 1].vs;
                            5:
                                begin
                                    compare;
                                    store^[sp].vb := not b;
                                end
                        end; (*case p*)
                    end;

19 (*geq*)
                :
                    begin
                        sp := sp - 1;
                        case p of
                            0:
                                errori(' <,<=,>,>= for address   ');
                            1:
                                store^[sp].vb := store^[sp].vi >= store^[sp + 1].vi;
                            6:
                                store^[sp].vb := store^[sp].vc >= store^[sp + 1].vc;
                            2:
                                store^[sp].vb := store^[sp].vr >= store^[sp + 1].vr;
                            3:
                                store^[sp].vb := store^[sp].vb >= store^[sp + 1].vb;
                            4:
                                store^[sp].vb := store^[sp].vs >= store^[sp + 1].vs;
                            5:
                                begin
                                    compare;
                                    store^[sp].vb := b or (store^[i1 + i].vi >= store^[i2 + i].vi)
                                end
                        end; (*case p*)
                    end;

20 (*grt*)
                :
                    begin
                        sp := sp - 1;
                        case p of
                            0:
                                errori(' <,<=,>,>= for address   ');
                            1:
                                store^[sp].vb := store^[sp].vi > store^[sp + 1].vi;
                            6:
                                store^[sp].vb := store^[sp].vc > store^[sp + 1].vc;
                            2:
                                store^[sp].vb := store^[sp].vr > store^[sp + 1].vr;
                            3:
                                store^[sp].vb := store^[sp].vb > store^[sp + 1].vb;
                            4:
                                errori(' set inclusion       ');
                            5:
                                begin
                                    compare;
                                    store^[sp].vb := not b and (store^[i1 + i].vi > store^[i2 + i].vi)
                                end
                        end; (*case p*)
                    end;

21 (*leq*)
                :
                    begin
                        sp := sp - 1;
                        case p of
                            0:
                                errori(' <,<=,>,>= for address   ');
                            1:
                                store^[sp].vb := store^[sp].vi <= store^[sp + 1].vi;
                            6:
                                store^[sp].vb := store^[sp].vc <= store^[sp + 1].vc;
                            2:
                                store^[sp].vb := store^[sp].vr <= store^[sp + 1].vr;
                            3:
                                store^[sp].vb := store^[sp].vb <= store^[sp + 1].vb;
                            4:
                                store^[sp].vb := store^[sp].vs <= store^[sp + 1].vs;
                            5:
                                begin
                                    compare;
                                    store^[sp].vb := b or (store^[i1 + i].vi <= store^[i2 + i].vi)
                                end;
                        end; (*case p*)
                    end;

22 (*les*)
                :
                    begin
                        sp := sp - 1;
                        case p of
                            0:
                                errori(' <,<=,>,>= for address   ');
                            1:
                                store^[sp].vb := store^[sp].vi < store^[sp + 1].vi;
                            6:
                                store^[sp].vb := store^[sp].vc < store^[sp + 1].vc;
                            2:
                                store^[sp].vb := store^[sp].vr < store^[sp + 1].vr;
                            3:
                                store^[sp].vb := store^[sp].vb < store^[sp + 1].vb;
                            5:
                                begin
                                    compare;
                                    store^[sp].vb := not b and (store^[i1 + i].vi < store^[i2 + i].vi)
                                end
                        end; (*case p*)
                    end;

23 (*ujp*)
                :
                    pc := q;

24 (*fjp*)
                :
                    begin
                        if not store^[sp].vb then
                            pc := q;
                        sp := sp - 1
                    end;

25 (*xjp*)
                :
                    begin
                        pc := store^[sp].vi + q;
                        sp := sp - 1
                    end;

95 (*chka*)
                :
                    if (store^[sp].va < np) or (store^[sp].va > (maxstr - q)) then
                        errori(' bad pointer value       ');

                96, 97, 98, 99, 26 (*chk*)
                :
                    if (store^[sp].vi < store^[q - 1].vi) or (store^[sp].vi > store^[q].vi) then
                        errori(' value out of range      ');

27 (*eof*)
                :
                    begin
                        i := store^[sp].vi;
                        if i = inputadr then
                            begin
                                store^[sp].vb := eof(input);
                            end
                        else
                            errori(' code in error       ')
                    end;

28 (*adi*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vi := store^[sp].vi + store^[sp + 1].vi
                    end;

29 (*adr*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vr := store^[sp].vr + store^[sp + 1].vr
                    end;

30 (*sbi*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vi := store^[sp].vi - store^[sp + 1].vi
                    end;

31 (*sbr*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vr := store^[sp].vr - store^[sp + 1].vr
                    end;

32 (*sgs*)
                :
                    store^[sp].vs := [store^[sp].vi];

33 (*flt*)
                :
                    store^[sp].vr := store^[sp].vi;

34 (*flo*)
                :
                    store^[sp - 1].vr := store^[sp - 1].vi;

35 (*trc*)
                :
                    store^[sp].vi := trunc(store^[sp].vr);

36 (*ngi*)
                :
                    store^[sp].vi := -store^[sp].vi;

37 (*ngr*)
                :
                    store^[sp].vr := -store^[sp].vr;

38 (*sqi*)
                :
                    store^[sp].vi := sqr(store^[sp].vi);

39 (*sqr*)
                :
                    store^[sp].vr := sqr(store^[sp].vr);

40 (*abi*)
                :
                    store^[sp].vi := abs(store^[sp].vi);

41 (*abr*)
                :
                    store^[sp].vr := abs(store^[sp].vr);

42 (*not*)
                :
                    store^[sp].vb := not store^[sp].vb;

43 (*and*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vb := store^[sp].vb and store^[sp + 1].vb
                    end;

44 (*ior*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vb := store^[sp].vb or store^[sp + 1].vb
                    end;

45 (*dif*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vs := store^[sp].vs - store^[sp + 1].vs
                    end;

46 (*int*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vs := store^[sp].vs * store^[sp + 1].vs
                    end;

47 (*uni*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vs := store^[sp].vs + store^[sp + 1].vs
                    end;

48 (*inn*)
                :
                    begin
                        sp := sp - 1;
                        i := store^[sp].vi;
                        store^[sp].vb := i in store^[sp + 1].vs;
                    end;

49 (*mod*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vi := store^[sp].vi mod store^[sp + 1].vi
                    end;

50 (*odd*)
                :
                    store^[sp].vb := odd(store^[sp].vi);

51 (*mpi*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vi := store^[sp].vi * store^[sp + 1].vi
                    end;

52 (*mpr*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vr := store^[sp].vr * store^[sp + 1].vr
                    end;

53 (*dvi*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vi := store^[sp].vi div store^[sp + 1].vi
                    end;

54 (*dvr*)
                :
                    begin
                        sp := sp - 1;
                        store^[sp].vr := store^[sp].vr / store^[sp + 1].vr
                    end;

55 (*mov*)
                :
                    begin
                        i1 := store^[sp - 1].va;
                        i2 := store^[sp].va;
                        sp := sp - 2;
                        for i := 0 to q - 1 do
                            store^[i1 + i] := store^[i2 + i]
               (* q is a number of storage units *)
                    end;

56 (*lca*)
                :
                    begin
                        sp := sp + 1;
                        store^[sp].va := q;
                    end;

                100, 101, 102, 103, 104, 57 (*dec*)
                :
                    store^[sp].vi := store^[sp].vi - q;

58 (*stp*)
                :
                    interpreting := false;

59 (*ord*)
                : (*only used to change the tagfield*)
                    begin
                    end;

60 (*chr*)
                :
                    begin
                    end;

61 (*ujc*)
                :
                    errori(' case - error        ');
            end
        end; (*while interpreting*)

1:


{Exit:}
    Writeln;
    Writeln('•••');
{Writeln('Hit return to exit');}
{readln(oldFile); {read to anything}
    writeln('Click mouse to exit.');
    while not Button do
        ;
end.